perm filename CYCDRA.LSP[3,LMM] blob
sn#038921 filedate 1973-04-26 generic text, type T, neo UTF8
(DEFPROP CYCDRAFNS
(CYCDRAFNS (SPECIAL XBOT
XSCL
YBOT
YSCL
REALWIDTH
REALHEIGHT
CTAB
PATS
CURPAT
PATSELECT
TITLE
LINE
LABELL
NLN
NMX
LLN
FIXE
FACENUM
REALBOTTOM
REALEFT
EPSILON)
PATS
PATSELECT
(ARRAY TMP T 20.)
(ARRAY CONN T 20.)
(ARRAY NODE T 40.)
PUSH
!
POP
STORENODEY
STORENODE
NODEY
DRAWS
PRINRAD
PRINENTRY
NUMNODES
LAYOUT
ANALIN
PRINRAD1
PRINCTAB
PRINRADOFF)
VALUE)
(SPECIAL XBOT
XSCL
YBOT
YSCL
REALWIDTH
REALHEIGHT
CTAB
PATS
CURPAT
PATSELECT
TITLE
LINE
LABELL
NLN
NMX
LLN
FIXE
FACENUM
REALBOTTOM
REALEFT
EPSILON)
(DEFPROP PATS
(PATS (TRAP ((1. 4. 3. 2.) (2. 4. 3. 1.) (3. 4. 2. 1.) (4. 3. 2. 1.))
(5. (4. 3. 3. 3. 3.)
((1. 4. (1. 2. 3. 4.))
(2. 3. (1. 3. 4.))
(3. 3. (1. 2. 4.))
(4. 3. (1. 2. 3.))
(5. 3. (2. 3. 4.))))
((4. 5. 3. 2. 1.) (3. 5. 4. 2. 1.) (2. 5. 4. 3. 1.) (1. 4. 3. 2. 1.))
(((3. . 4.) 1.) ((2. . 4.) 1.) ((2. . 3.) 1.) ((1. . 4.) 1.) ((1. . 3.) 1.) ((1. . 2.) 1.))
((1. 0. 0.) (2. 1. 2.) (3. 2. 0.) (4. 1. 1.)))
(HEX ((1. 2. 6.) (2. 3. 1.) (3. 4. 2.) (4. 5. 3.) (5. 6. 4.) (6. 5. 1.))
(1. (6.) ((1. 6. (1. 6. 5. 4. 3. 2.))))
((6. 1.) (5. 1.) (4. 1.) (3. 1.) (2. 1.) (1. 1.))
(((5. . 6.) 1.) ((4. . 5.) 1.) ((3. . 4.) 1.) ((2. . 3.) 1.) ((1. . 2.) 1.) ((1. . 6.) 1.))
((1. 1. 3.) (2. 2. 2.) (3. 2. 1.) (4. 1. 0.) (5. 0. 1.) (6. 0. 2.)))
(PENT ((1. 5. 2.) (2. 3. 1.) (3. 4. 2.) (4. 5. 3.) (5. 1. 4.))
(1. (5.) ((1. 5. (1. 2. 3. 4. 5.))))
((5. 1.) (4. 1.) (3. 1.) (2. 1.) (1. 1.))
(((4. . 5.) 1.) ((3. . 4.) 1.) ((2. . 3.) 1.) ((1. . 5.) 1.) ((1. . 2.) 1.))
((1. 0. 1.) (2. 1. 2.) (3. 2. 1.) (4. 2. 0.) (5. 0. 0.)))
(OCT ((1. 2. 8.) (2. 3. 1.) (3. 4. 2.) (4. 5. 3.) (5. 6. 4.) (6. 7. 5.) (7. 8. 6.) (8. 1. 7.))
(1. (8.) ((1. 8. (1. 8. 7. 6. 5. 4. 3. 2.))))
((8. 1.) (7. 1.) (6. 1.) (5. 1.) (4. 1.) (3. 1.) (2. 1.) (1. 1.))
(((7. . 8.) 1.) ((6. . 7.) 1.)
((5. . 6.) 1.)
((4. . 5.) 1.)
((3. . 4.) 1.)
((2. . 3.) 1.)
((1. . 2.) 1.)
((1. . 8.) 1.))
((1. 0. 2.) (2. 1. 3.) (3. 2. 3.) (4. 3. 2.) (5. 3. 1.) (6. 2. 0.) (7. 1. 0.) (8. 0. 1.))))
VALUE)
(DEFPROP PATSELECT
(PATSELECT (4. 15. 15.) (3. 16. 17.) (1. 17. 15.) (2. 16. 16.))
VALUE)
(ARRAY TMP T 20.)
(ARRAY CONN T 20.)
(ARRAY NODE T 40.)
(DEFPROP PUSH
(LAMBDA (X) (LIST (QUOTE SETQ) (QUOTE STACK) (APPEND (QUOTE (! CONS)) (CDR X) (QUOTE (STACK)))))
MACRO)
(DEFPROP !
(LAMBDA(L)
((LABEL FOO
(LAMBDA(LL)
(COND ((NULL (CDR LL)) NIL)
((NULL (CDDR LL)) (CADR LL))
((NULL (CDDDR LL)) LL)
(T (LIST (CAR LL) (CADR LL) (FOO (CONS (CAR LL) (CDDR LL))))))))
(CDR L)))
MACRO)
(DEFPROP POP
(LAMBDA(X)
(LIST (QUOTE PROG1) (LIST (QUOTE SETQ) (CADR X) (QUOTE (CAR STACK))) (QUOTE (SETQ STACK (CDR STACK)))))
MACRO)
(DEFPROP STORENODEY
(LAMBDA (EXPR) (LIST (QUOTE STORE) (LIST (QUOTE NODE) (LIST (QUOTE PLUS) 20. (CADR EXPR))) (CADDR EXPR)))
MACRO)
(DEFPROP STORENODE
(LAMBDA (L) (LIST (QUOTE STORE) (LIST (QUOTE NODE) (CADR L)) (CADDR L)))
MACRO)
(DEFPROP NODEY
(LAMBDA (L) (LIST (QUOTE NODE) (LIST (QUOTE PLUS) 20. (CADR L))))
MACRO)
(DEFPROP DRAWS
(LAMBDA(STRUC ID)
(PROG (CTAB)
(SETQ CTAB (CTABLE STRUC))
(LAYOUT
(CONS (COND (ID ID) (T (UGRAPH STRUC)))
(FOR NEW
CTE
IN
CTAB
LIST
(CONS (NODENUM CTE)
(CONS (ATOMTYPE (MARKERS CTE))
(FOR NEW X IN (NBRS CTE) WHEN (NUMBERP X) LIST X))))))))
EXPR)
(DEFPROP PRINRAD
(LAMBDA(L)
(PROG (PRINRADCTAB)
(PRINRAD1 NIL (FOR NEW I := ((NUMNODES L) 1. -1.) XLIST I) L)
(LAYOUT (CONS TITLE PRINRADCTAB))))
EXPR)
(DEFPROP PRINENTRY
(LAMBDA (N AT CON) (SETQ PRINRADCTAB (CONS (CONS N (CONS AT CON)) PRINRADCTAB)))
EXPR)
(DEFPROP NUMNODES
(LAMBDA(RAD)
(FOR NEW
R
IN
(ATTACHEDRADS RAD)
PLUS
FIRST
(IF (NULL (CENTER RAD))
THEN
0.
ELSEIF
(ATOM (CENTER RAD))
THEN
1.
ELSEIF
(NOT (STRUCTURE? (RADSTRUC (CENTER RAD))))
THEN
1.
ELSE
(LENGTH (NODES (RADSTRUC (CENTER RAD)))))
(TIMES (CDR R) (NUMNODES (CAR R)))))
EXPR)
(DEFPROP LAYOUT
(LAMBDA (X) (PROG NIL (ANALIN X) (PATMATCH) (SORTLN) (FINDNDS 1. NIL) (RETURN (OUTNDS))))
EXPR)
(DEFPROP ANALIN
(LAMBDA(X)
(PROG (X1 X2 X3 X4)
(FOR NEW I := (1. 19.) DO (STORE (CONN I) NIL))
(SETQ TITLE (CAR X))
(SETQ LINE NIL)
(SETQ LABELL NIL)
(SETQ NLN (LENGTH (CDR X)))
(SETQ NMX 0.)
(FOR X1
IN
(CDR X)
AS
NMX
IS
(MAX (CAR X1) NMX)
AS
X2
IS
(CAR X1)
AS
LABELL
IS
(CONS (CONS X2 (CADR X1)) LABELL)
FOR
X3
IN
(CDDR X1)
DO
(SETQ X4 (ASSOC2 (CONS X2 X3) LINE))
(COND ((NULL X4)
(COND ((ASSOC2 (CONS X3 X2) LINE) NIL) (T (SETQ LINE (CONS (LIST (CONS X2 X3) 1.) LINE)))))
(T (RPLACA (CDR X4) (ADD1 (CADR X4)))))
(COND ((MEMBER X3 (CONN X2)) NIL) (T (STORE (CONN X2) (CONS X3 (CONN X2))))))
(SETQ LLN (LENGTH LINE))
(RETURN LINE)))
EXPR)
(DEFPROP PRINRAD1
(LAMBDA(EFF AA RAD)
(PROG (CENT ATTACHED J X TTABLE)
(SETQ CENT (CENTER RAD))
(SETQ ATTACHED (CLEXPAND (ATTACHEDRADS RAD)))
(RETURN
(IF (NOT CENT)
THEN
(PRINRAD1 (CADR AA) (CONS (CAR AA) (PRINRAD1 (CAR AA) (CDR AA) (CAR ATTACHED))) (CADR ATTACHED))
ELSEIF
(OR (ATOM CENT) (NOT (EQ (ID (RADSTRUC CENT)) (QUOTE STRUC))))
THEN
(SETQ X (CDR AA))
(FOR NEW R IN ATTACHED DO (SETQ J (CONS (CAR X) J)) (SETQ X (PRINRAD1 (CAR AA) X R)))
(PRINENTRY (CAR AA) CENT (IF EFF THEN (CONS EFF J) ELSE J))
X
ELSE
(SETQ X
(IF (NOT EFF) THEN AA ELSE (SETQ TTABLE (LIST (LIST (AFFLINK CENT) (CAR AA) EFF))) (CDR AA)))
(FOR NEW
N
IN
(NODES (RADSTRUC CENT))
WHEN
(NOT (EQUAL N (AFFLINK CENT)))
DO
(SETQ TTABLE (CONS (LIST N (CAR X)) TTABLE))
(SETQ X (CDR X)))
(FOR NEW
NLIST
IN
(CUFFLINKS CENT)
FOR
NEW
C
IN
NLIST
AS
NEW
CT
IS
(LMASSOC C TTABLE NIL)
DO
(NCONC CT (LIST (CAR X)))
(SETQ X (PRINRAD1 (CAR CT) X (CAR ATTACHED)))
(SETQ ATTACHED (CDR ATTACHED)))
(PRINCTAB (CTABLE (RADSTRUC CENT)) TTABLE)
X))))
EXPR)
(DEFPROP PRINCTAB
(LAMBDA(CTAB TTABLE)
(FOR NEW
CT
IN
CTAB
AS
NEW
CPRIME
IS
(LMASSOC (NODENUM CT) TTABLE NIL)
DO
(PRINENTRY (CAR CPRIME)
(ATOMTYPE MARKERS CT)
(APPEND (CDR CPRIME)
(FOR NEW
Y
IN
(NBRS CT)
IF
(NOT (EQ Y (QUOTE FV)))
XLIST
(CAR (LMASSOC Y TTABLE NIL)))))))
EXPR)
(DEFPROP PRINRADOFF
(LAMBDA(L)
(PROG NIL
(QUOTE (TTAB 1.))
(PRIN1 (QUOTE STRUCTURE=))
(PRINT L)
(FOR NEW X IN XLATETABLE DO (PRIN1 (QUOTE X)) (PRIN1 (CAR X)) (PRIN1 (QUOTE =)) (PRINT (CDR X)))
(QUOTE (TTAB 1.))
(PRINT (QUOTE END*))
(QUOTE (OTLL 133.))
(SETQ XLATETABLE NIL)))
EXPR)